Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue45/System/EXBitmap.pas

Pascal/Delphi Source File | 2000-11-02 | 10.8 KB | 348 lines

unit EXBitmap;

interface

uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs;

type
    TExBrightness = -255..255;

    TExBitmap = class (TBitmap)
    private
        fChangeLock: Boolean;                    // True if we're altering image
        fOriginal: TBitmap;                      // original bitmap image
        fBrightness: TExBrightness;              // current brightness level
        fFlipped: Boolean;                       // if image is vertically flipped
        fMirrored: Boolean;                      // if image is horizontally mirrored
        fInverted: Boolean;                      // if image is inverted (negative)
        fBlurRadius: Double;                     // radius for Gaussian blur
        fWeights: array [-100..100] of single;
        fSize: 1..100;
        procedure SetBrightness (Value: TExBrightness);
        procedure SetMirrored (Value: Boolean);
        procedure SetInverted (Value: Boolean);
        procedure SetFlipped (Value: Boolean);
        procedure SetBlurRadius (Value: Double);
        procedure InitGaussianWeightings;
        procedure BlurRow (S, D: Pointer; Count: Integer);
    protected
        procedure Changed (Sender: TObject); override;
    public
        constructor Create; override;
        destructor Destroy; override;
        procedure GaussianBlur;
        property Flipped: Boolean read fFlipped write SetFlipped default False;
        property Mirrored: Boolean read fMirrored write SetMirrored default False;
        property Brightness: TExBrightness read fBrightness write SetBrightness default 0;
        property Inverted: Boolean read fInverted write SetInverted default False;
        property BlurRadius: Double read fBlurRadius write SetBlurRadius;
    end;

implementation

type
    // Override the definitions in Windows.pas
    PRGBQuad = ^TRGBQuad;
    TRGBQuad = packed record
        r: Byte;
        g: Byte;
        b: Byte;
        rgbReserved: Byte;
    end;

    // Override the definitions in Graphics.pas
    TRGBQuadArray = array [Word] of TRGBQuad;
    PRGBQuadArray = ^TRGBQuadArray;

{ TExBitmap }

constructor TExBitmap.Create;
begin
    Inherited Create;
    fBlurRadius := 3.0;
    fOriginal := TBitmap.Create;
end;

destructor TExBitmap.Destroy;
begin
    fOriginal.Free;
    Inherited Destroy;
end;

procedure TExBitmap.Changed (Sender: TObject);
begin
    Inherited Changed (Sender);
    if not fChangeLock then begin
        PixelFormat := pf32Bit;
        fBrightness := 0;
        fFlipped := False;
        fMirrored := False;
        fInverted := False;
        // Force a *COPY* of the bitmap.  >>DONT<< call Assign!
        fOriginal.Width := Width;  fOriginal.Height := Height;
        fOriginal.Canvas.Draw (0, 0, Self);
        fOriginal.PixelFormat := pf32Bit;
    end;
end;

procedure TExBitmap.SetBrightness (Value: TExBrightness);
var
    Row, Col: Integer;
    Line: PRGBQuadArray;
begin
    if (not Empty) and (fBrightness <> Value) then begin
        fBrightness := Value;
        fChangeLock := True;
        // Get an unadulterated copy of the image
        Canvas.Draw (0, 0, fOriginal);
        Assert (PixelFormat = pf32Bit);
        for Row := 0 to Height - 1 do begin
            Line := ScanLine [Row];
            for Col := 0 to Width - 1 do
                with Line [Col] do
                    if Value > 0 then begin
                        if r + Value > 255 then r := 255 else Inc (r, Value);
                        if g + Value > 255 then g := 255 else Inc (g, Value);
                        if b + Value > 255 then b := 255 else Inc (b, Value);
                    end else begin
                        if r + Value < 0 then r := 0 else Inc (r, Value);
                        if g + Value < 0 then g := 0 else Inc (g, Value);
                        if b + Value < 0 then b := 0 else Inc (b, Value);
                    end;
        end;

        fChangeLock := False;
        Inherited Changed (Self);
    end;
end;

procedure TExBitmap.SetFlipped (Value: Boolean);

    procedure FlipBitmap (bmp: TBitmap);
    var
        TempScanLine: Pointer;
        ScanLineBytes, Row, H: Integer;
    begin
        with bmp do begin
            Assert (PixelFormat = pf32Bit);
            H := Height;
            ScanLineBytes := Width * sizeof (TRGBQuad);
            GetMem (TempScanLine, ScanLineBytes);

            for Row := 0 to ((H and (-2)) - 1) div 2 do begin
                Move (ScanLine [Row]^, TempScanLine^, ScanLineBytes);
                Move (ScanLine [H - Row - 1]^, ScanLine [Row]^, ScanLineBytes);
                Move (TempScanLine^, ScanLine [H - Row - 1]^, ScanLineBytes);
            end;
        end;

        FreeMem (TempScanLine);
    end;

begin
    if (not Empty) and (Value <> fFlipped) then begin
        fFlipped := Value;
        FlipBitmap (Self);
        // Lossless operation - so apply to original also.
        FlipBitmap (fOriginal);
        Inherited Changed (Self);
    end;
end;

procedure TExBitmap.SetMirrored (Value: Boolean);

    procedure MirrorBitmap (bmp: TBitmap);
    var
        Temp: TRGBQuad;
        Row, Col, W: Integer;
        Line: PRGBQuadArray;
    begin
        with bmp do begin
            Assert (PixelFormat = pf32Bit);
            W := Width;
            for Row := 0 to Height - 1 do begin
                Line := ScanLine [Row];
                for Col := 0 to ((W and (-2)) - 1) div 2 do begin
                    Temp := Line [Col];
                    Line [Col] := Line [W - Col - 1];
                    Line [W - Col - 1] := Temp;
                end;
            end;
        end;
    end;

begin
    if (not Empty) and (Value <> fMirrored) then begin
        fMirrored := Value;
        MirrorBitmap (Self);
        // Lossless operation - so apply to original also.
        MirrorBitmap (fOriginal);
        Inherited Changed (Self);
    end;
end;

procedure TExBitmap.SetInverted (Value: Boolean);

    procedure InvertBitmap (bmp: TBitmap);
    var
        Row, Col: Integer;
        Line: PRGBQuadArray;
    begin
        with bmp do begin
            Assert (PixelFormat = pf32Bit);
            for Row := 0 to Height - 1 do begin
                Line := ScanLine [Row];
                for Col := 0 to Width - 1 do
                    with Line [Col] do begin
                        r := not r;
                        g := not g;
                        b := not b;
                    end;
            end;
        end;
    end;

begin
    if (not Empty) and (Value <> fInverted) then begin
        fInverted := Value;
        InvertBitmap (Self);
        // Lossless operation - so apply to original also.
        InvertBitmap (fOriginal);
        Inherited Changed (Self);
    end;
end;

procedure TExBitmap.InitGaussianWeightings;
const
    delta: Double = 1.0 / 510;    // Smaller entries are ignored
    LastRadius: Double = 0.0;
var
    Idx: Integer;
    D: Double;

    procedure Normalise (Lo, Hi: Integer);
    var
        Total: Double;
        Idx: Integer;
    begin
        Total := 0;
        for Idx := Lo to Hi do Total := Total + fWeights [Idx];
        for Idx := Lo to Hi do fWeights [Idx] := fWeights [Idx] / Total;
    end;

begin
    // If same radius as requested last time, nothing to do....
    if fBlurRadius = LastRadius then Exit;
    LastRadius := fBlurRadius;

    // Init the weights array with standard deviation = fBlurRadius
    for Idx := Low (fWeights) to High (fWeights) do begin
        D := Idx / fBlurRadius;  fWeights [Idx] := exp (- D * D / 2);
    end;

    // Normalise around maximum bounds
    Normalise (Low (fWeights), High (fWeights));

    // Discard entries smaller than Delta
    fSize := High (fWeights);  D := 0;
    while (D < delta) and (fSize > 1) do begin
        D := D + 2 * fWeights [fSize];
        Dec (fSize);
    end;

    // Normalise again, using new bounds
    Normalise (-fSize, fSize);
end;

procedure TExBitmap.BlurRow (S, D: Pointer; Count: Integer);
var
    Idx, Pix, j, n: Integer;
    rr, gg, bb, w: Double;
    Src: PRGBQuadArray absolute S;
    Dest: PRGBQuadArray absolute D;
begin
    for j := 0 to Count - 1 do begin
        rr := 0; gg := 0; bb := 0;
        for n := -fSize to fSize do begin
            w := fWeights [n];  Idx := j - n;
            // Ensure index is pinned between 0..Count-1
            if Idx < 0 then Idx := 0 else if Idx > Count - 1 then Idx := Count - 1;
            with Src [Idx] do begin
                rr := rr + w * r;
                gg := gg + w * g;
                bb := bb + w * b;
            end;
        end;

        with Dest [j] do begin
            Pix := Trunc (rr);
            if Pix < 0 then Pix := 0 else if Pix > 255 then Pix := 255;
            r := Pix;

            Pix := Trunc (gg);
            if Pix < 0 then Pix := 0 else if Pix > 255 then Pix := 255;
            g := Pix;

            Pix := Trunc (bb);
            if Pix < 0 then Pix := 0 else if Pix > 255 then Pix := 255;
            b := Pix;
        end;
    end;
end;

procedure TExBitmap.SetBlurRadius (Value: Double);
begin
    if Value > 0.0 then fBlurRadius := Value;
end;

procedure TExBitmap.GaussianBlur;
type
    PPRows = ^TPRows;
    TPRows = array[Word] of PRGBQuadArray;
var
    Rows: PPRows;
    Column, Scratch: PRGBQuadArray;
    ScanLineBytes, H, W, Row, Col: Integer;
begin
    if not Empty then begin
        fChangeLock := True;
        // Get a copy of the original image
        Canvas.Draw (0, 0, fOriginal);
        Assert (PixelFormat = pf32Bit);
        H := Height;  W := Width;
        ScanLineBytes := W * sizeof (TRGBQuad);
        InitGaussianWeightings;
        GetMem (Rows, H * sizeof (Pointer));
        GetMem (Column, H * sizeof (TRGBQuad));

        // Retrieve the address of each bitmap scanline
        for Row := 0 to H - 1 do Rows [Row]:= Scanline [Row];

        // Blur each row
        GetMem (Scratch, ScanLineBytes);
        for Row := 0 to H - 1 do begin
            BlurRow (Rows [Row], Scratch, W);
            Move (Scratch^, Rows [Row]^, W * sizeof (TRGBQuad));
        end;

        // Blur each column
        ReallocMem (Scratch, H * sizeof (TRGBQuad));
        for Col := 0 to W - 1 do begin
            // first read the column into a TRow
            for Row := 0 to H - 1 do Column [Row] := Rows [Row][Col];
            BlurRow (Column, Scratch, H);
            // Replace the column in the destination bitmap
            for Row := 0 to H - 1 do Rows [Row][Col] := Scratch [Row];
        end;

        FreeMem (Rows);
        FreeMem (Column);
        FreeMem (Scratch);
        fChangeLock := False;
        Inherited Changed (Self);
    end;
end;

end.